home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
pascal
/
tpb4_src.zip
/
MSGREAD.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-09-13
|
24KB
|
702 lines
{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault
Last modified :: 5-27-88 8:11 pm
}
{$R-} {Range checking off}
{$B-} {Boolean complete evaluation off}
{$S-} {Stack checking off}
{$I+} {I/O checking on}
{$N-} {No numeric coprocessor}
Unit MsgRead;
Interface
Uses
TPCrt, TPDOS, Globals, TAccess, Core1, Core2,
MsgMove, MsgEntr, MsgMisc, EditUsr1, EditUsr2;
procedure mesg_header_list(loc : Integer;
var first_line,
last_line : Integer;
var Fr_fn : FirstName;
var Fr_ln : LastName);
procedure mesg_quick_scan;
procedure mesg_summary;
procedure mesg_read;
{==========================================================================}
Implementation
procedure SysopCmds(var update : Boolean);
var
ch, drive : Char;
work : DosFileName;
This : AreaPtr;
temp_name : DosFileName;
begin
repeat
WriteLn(Com);
st := prompt('Sysop Message command <D><H><I><M><N><P><R><Q><?>', 80, 'ES?');
if Length(st) = 1 then
ch := st[1]
else
ch := '?';
case ch of
'D' :
begin
summ_rec.status := deleted;
summ_rec.num_prev := 0;
end;
'H' :
summ_rec.status := restricted;
'I' :
summ_rec.status := private;
'M' :
begin
abort := False;
repeat
This := AreaBase;
work := prompt('Message Area ', 12, 'ES?M');
if work = '?' then
begin
WriteLn(Com, 'Available Message Areas:');
WriteLn(Com);
while (not brk) and (This <> nil) do
begin
if This^.AreaName[1] <> '-' then
WriteLn(Com, This^.AreaName)
else
begin
temp_name := This^.AreaName;
Delete(temp_name, 1, 1);
WriteLn(Com, temp_name)
end;
This := This^.next;
end;
end;
This := AreaBase; {set up to find name match}
while (This <> nil) and (This^.AreaName <> work) and
(Pos(work, This^.AreaName) <> 2) do
This := This^.next;
until (work = This^.AreaName) or (brk) or (not Online)
or (Pos(work, This^.AreaName) = 2);
if (This^.AreaName[1] = '-') or (This^.AreaName = 'NETMAIL') then
begin
drive := DefaultDrive;
work := drive+':\TEMP.MSG';
record_msg(work);
make_fido_message(This^.AreaName, work, summ_rec.user_from,
summ_rec.user_to, summ_rec.subject,
False, '', 0, 0, False);
end
else
summ_rec.Area := This^.Area;
end;
'N' :
begin
if summ_rec.num_prev = 0 then
summ_rec.num_prev := 255
else
summ_rec.num_prev := 0;
if summ_rec.num_prev = 255 then
Write(Com, 'NOT ');
WriteLn(Com, 'subject to purge.');
end;
'P' :
summ_rec.status := public;
'R' :
summ_rec.status := Seen
else
WriteLn(Com, '<D>elete, <H>ide, pr<I>vate, <M>ove, <N>o Purge, <P>ublic, <R>ead, <Q>uit')
end
until (not Online) or (ch in ['D', 'H', 'I', 'M', 'N', 'P', 'R', 'Q']);
update := True;
end; {SysopCmds}
function mesg_start(pr : StrPr) : Integer;
{ Get starting message number from user }
var
i, last : Integer;
begin
repeat
WriteLn(Com);
last := user_rec.lasthi;
i := strint(prompt(pr+' (last mesg you read is '+intstr(last, 1)+') '+' ['+intstr(msg_lo,
1)+'-'+intstr(msg_hi, 1)+']?', 5, 'E'));
if ((i < msg_lo) or (i > msg_hi)) and (i <> 0) then
WriteLn(Com, 'Invalid message number, try again.');
until ((i >= msg_lo) and (i <= msg_hi)) or (i = 0) or (not Online);
mesg_start := i
end;
procedure mesg_header_list(loc : Integer;
var first_line,
last_line : Integer;
var Fr_fn : FirstName;
var Fr_ln : LastName);
{ Display message header }
var
to_fn : FirstName;
to_ln : LastName;
Str : StrTAD;
temp_user_rec : user_list;
This : AreaPtr;
from_temp,
to_temp : Str36;
begin
Write(Com, yellow);
Seek(summ_file, loc);
Read(summ_file, summ_rec);
with summ_rec do
begin
if user_to = 0 then
begin
to_fn := 'ALL';
to_ln := ''
end
else if user_to = user_loc then
begin
to_fn := user_rec.fn;
to_ln := user_rec.ln
end
else
begin
if user_to <> -1 then
begin
GetRec(DatF, user_to, temp_user_rec);
to_fn := temp_user_rec.fn;
to_ln := temp_user_rec.ln;
end
else
begin
to_fn := 'Deleted';
to_ln := 'User';
end;
end;
if user_from = user_loc then
begin
Fr_fn := user_rec.fn;
Fr_ln := user_rec.ln
end
else
begin
if user_from <> -1 then
begin
GetRec(DatF, user_from, temp_user_rec);
Fr_fn := temp_user_rec.fn;
Fr_ln := temp_user_rec.ln;
end
else
begin
Fr_fn := 'Deleted';
Fr_ln := 'User';
end;
end;
Str := FormTAD(date);
This := AreaBase;
while (This <> nil) and (This^.Area <> Area) do
This := This^.next;
WriteLn(Com);
if num_prev = 255 then
Write(Com, '<P>');
case status of
deleted :
Write(Com, 'Deleted');
Seen :
Write(Com, 'Read');
private :
Write(Com, 'Private');
public :
Write(Com, 'Public');
restricted :
Write(Com, 'Restricted');
end;
WriteLn(Com, ' message # ', num, ' ', This^.AreaName, ' AREA ', ' Entered ', Str);
from_temp := Fr_fn+' '+Fr_ln;
{$V-}
caps_to_mixed(from_temp);
to_temp := to_fn+' '+to_ln;
caps_to_mixed(to_temp) {$V+} ;
WriteLn(Com, white, 'From: ', cyan, from_temp);
WriteLn(Com, white, ' To: ', cyan, to_temp);
WriteLn(Com, white, ' Re: ', cyan, subject, yellow);
if audit_on then
begin
SetSect(AudName);
WriteLn(AuditFile);
if num_prev = 255 then
Write(AuditFile, '<P>');
case status of
deleted :
Write(AuditFile, 'Deleted');
Seen :
Write(AuditFile, 'Read');
private :
Write(AuditFile, 'Private');
public :
Write(AuditFile, 'Public');
restricted :
Write(AuditFile, 'Restricted');
end;
WriteLn(AuditFile, ' message # ', num, ' entered ', Str);
WriteLn(AuditFile, 'From: ', Fr_fn, ' ', Fr_ln);
WriteLn(AuditFile, ' To: ', to_fn, ' ', to_ln);
WriteLn(AuditFile, ' Re: ', subject);
SetSect(HomName);
end;
first_line := st_rec;
last_line := size
end
end; {message header list}
procedure mesg_quick_scan;
{ Print abbreviated summary of messages }
var
private : Boolean;
sep : Char;
num,
line_count : Integer;
begin
line_count := 0;
private := False;
num := mesg_start('Start');
if num <> 0 then
begin
MesgCurr := MesgBase;
while (MesgCurr <> nil) and (MesgCurr^.MesgNo < num) do
MesgCurr := MesgCurr^.next;
WriteLn(Com);
abort := False;
while (not brk) and (MesgCurr <> nil) do
begin
if (MesgCurr^.TypMsg = 1) or (MesgCurr^.TypMsg = 2) then
begin
private := True;
sep := '*'
end
else
sep := ':';
Seek(summ_file, MesgCurr^.SummLoc);
Read(summ_file, summ_rec);
WriteLn(Com, MesgCurr^.MesgNo, sep, ' ', summ_rec.subject);
MesgCurr := MesgCurr^.next;
if user_rec.lines <> 99 then
begin
Inc(line_count);
if line_count mod user_rec.lines = 0 then
pause
end
end;
if private then
begin
WriteLn(Com);
WriteLn(Com, '"*" marks messages to or from you.')
end
end;
end;
procedure mesg_summary;
{ Message summary }
var
num,
first_line,
last_line,
line_count : Integer;
Fr_fn : FirstName;
Fr_ln : LastName;
begin
line_count := 0;
abort := False;
num := mesg_start('Start');
if num <> 0 then
begin
MesgCurr := MesgBase;
while (MesgCurr <> nil) and (MesgCurr^.MesgNo < num) do
MesgCurr := MesgCurr^.next;
while (not brk) and (MesgCurr <> nil) do
begin
mesg_header_list(MesgCurr^.SummLoc, first_line, last_line, Fr_fn, Fr_ln);
MesgCurr := MesgCurr^.next;
if user_rec.lines <> 99 then
begin
Inc(line_count);
if line_count mod (user_rec.lines div 5) = 0 then
pause
end
end
end;
end;
procedure mesg_read;
{ Read message }
var
This : MesgPtr;
ch, option : Char;
pr_str,
Dirspec : StrPr;
RefDrv : Str3;
Fr_fn : FirstName;
Fr_ln : LastName;
update, skip,
backup, OK : Boolean;
i, num,
first_line,
last_line,
line_count,
strt : Integer;
RefFile,
RefSect : DosFileName;
this_type : Byte;
begin
OK := True;
nonstop := False;
MesgCurr := MesgBase;
num := 0;
abort := False;
repeat
WriteLn(Com);
st := prompt('Read Search Option <A><F><T><N><S><Q> ', 80, 'ES?M');
if Length(st) = 1 then
option := st[1]
else
option := '?';
if option = '?' then
begin
WriteLn(Com, '<A>ll, <F>rom you, <T>o you <N>umeric, <S>ince your last call, <Q>uit')
;
mult_cmds := False;
Cmd_Queue := '';
end;
until (not Online) or (option in ['A', 'F', 'T', 'N', 'S', 'Q']);
case option of
'A' :
if MesgBase <> nil then
num := MesgBase^.MesgNo;
'N' :
begin
num := mesg_start('Start'); {get starting number}
if num = 0 then OK := False;
end;
'F' :
begin
if msg_aut = 0 then
begin
OK := False;
WriteLn(Com, 'No Messages From You.');
end;
end;
'T' :
begin
if msg_ind = 0 then
begin
OK := False;
WriteLn(Com, 'No Messages for you.');
end;
end;
'S' :
num := Succ(user_rec.lasthi);
'Q' :
OK := False;
end;
if ((num > 0) and (OK)) then
while (MesgCurr <> nil) and (MesgCurr^.MesgNo < num) do
MesgCurr := MesgCurr^.next;
while (not brk) and (MesgCurr <> nil) and OK and Online do
begin
backup := False;
skip := False;
update := False;
if option = 'F' then
while (MesgCurr <> nil) and (MesgCurr^.TypMsg <> 2) do
MesgCurr := MesgCurr^.next;
if option = 'T' then
while (MesgCurr <> nil) and (MesgCurr^.TypMsg <> 1) do
MesgCurr := MesgCurr^.next;
if (MesgCurr <> nil) then
begin
if MesgCurr^.MesgNo > temp_hi_lmr then
temp_hi_lmr := MesgCurr^.MesgNo;
mesg_header_list(MesgCurr^.SummLoc, first_line, last_line, Fr_fn, Fr_ln);
line_count := 4;
if (not nonstop) then
begin
repeat
repeat
WriteLn(Com);
pr_str := white+intstr(time_left, 1)+'-'+yellow+'Read <Y><N><C><Q><P><R>';
if user_rec.access >= 250 then
pr_str := pr_str+'<X><E><V><S>';
st := prompt(pr_str+cyan, 1, 'ESA?M');
if Length(st) = 1 then
ch := st[1]
else
ch := '?';
if (user_rec.access < 250) and ((ch = 'X') or (ch = 'E')
or (ch = 'S') or (ch = 'V'))
then
ch := '?';
if ch = '?' then
begin
WriteLn(Com,
'<Y>es, <N>o, <C>ontinuous, <Q>uit, <P>revious, <R>eply');
if user_rec.access >= 250 then
WriteLn(Com,
'<X> Sysop Commands, <E>dit or <V>alidate caller, <S>ave to disk');
mult_cmds := False;
Cmd_Queue := '';
end;
until (not Online) or
(ch in ['Y', 'N', 'C', 'Q', 'P', 'R', 'X', 'E', 'V', 'S']);
case ch of
'Q' :
OK := False;
'C' :
nonstop := True;
'N' :
skip := True;
'P' :
backup := True;
'R' :
begin
skip := True;
if user_rec.access >= val_acc then
mesg_enter('A')
else
WriteLn(Com, 'Replys not accepted until validation.');
end;
'S' :
if user_rec.access >= 250 then
begin
record_msg('');
skip := True;
end;
'X' :
if user_rec.access >= 250 then
begin
SysopCmds(update);
skip := True;
end
else
OK := False;
'E' :
begin
if user_rec.access >= 250 then
edit_user(Fr_fn, Fr_ln, 0)
else
OK := False;
mesg_header_list(MesgCurr^.SummLoc, first_line,
last_line, Fr_fn, Fr_ln);
end;
'V' :
begin
if user_rec.access >= 250 then
Validate_user(Fr_fn, Fr_ln)
else
OK := False;
mesg_header_list(MesgCurr^.SummLoc, first_line,
last_line, Fr_fn, Fr_ln);
end;
end;
until ((ch <> 'E') and (ch <> 'V')) or (not Online);
end; {not nonstop}
WriteLn(Com);
if (not skip) and (OK) and (not backup) then
begin
check_time;
i := 1;
Seek(mesg_file, first_line);
while (not brk) and (i <= last_line) and Online do
begin
Read(mesg_file, mesg_rec);
strt := Pos('//', mesg_rec); { format: //section/filename/ }
if (strt > 0) and (summ_rec.num_next > 0) then
begin
RefSect := '';
RefFile := '';
strt := strt+2; {offset}
while (mesg_rec[strt] <> '/') and (strt <= Length(mesg_rec)) do
begin
RefSect := RefSect+Upcase(mesg_rec[strt]);
Inc(strt);
end;
Inc(strt); {offset again}
while (mesg_rec[strt] <> '/') and (strt <= Length(mesg_rec)) do
begin
RefFile := RefFile+Upcase(mesg_rec[strt]);
Inc(strt);
end;
if (RefSect <> '') and (RefFile <> '') then
begin
FindSect(RefSect, RefDrv, OK);
if OK then
begin
if RefSect = 'SYSTEM' then
Dirspec := HomName
else
begin
Dirspec := RefDrv;
if (Length(HomName) > 3) and (Dirspec = HomDrv
) then
begin
Dirspec := Dirspec+Copy(HomName, 4,
Length(HomName));
Dirspec := Dirspec+'\';
end;
Dirspec := Dirspec+RefSect;
end;
list_file(RefFile, Dirspec);
line_count := 1;
end
else
OK := True; {preset for next msg. }
end;
end
else
WriteLn(Com, mesg_rec); {type message lines}
Inc(i);
if (user_rec.lines <> 99) and (not nonstop) then
begin
Inc(line_count);
if line_count mod user_rec.lines = 0 then
pause;
end;
end; {print msg text}
update := (summ_rec.user_to = user_loc) and ((summ_rec.status = private) or
(summ_rec.status = public));
if update then
summ_rec.status := Seen;
if ((summ_rec.user_from = user_loc) or (summ_rec.user_to = user_loc)) and (
not nonstop) and
(not backup) and (summ_rec.status <> deleted) then
begin
i := 0;
WriteLn(Com);
pr_str := 'DELETE this message';
if (summ_rec.user_to = user_loc) then
if ask(white+'Reply to Message'+cyan, 'N') then
begin
i := MesgCurr^.SummLoc;
mesg_enter('A');
pr_str := 'DELETE original message';
end;
WriteLn(Com);
if ask(white+pr_str+cyan, 'N') then
begin
if ask(white+'Are you sure'+cyan, 'N') then
begin
if i > 0 then
begin
Seek(summ_file, i);
Read(summ_file, summ_rec);
end;
summ_rec.status := deleted;
update := True;
MesgCurr := MesgCurr^.next;
WriteLn(Com, 'Message deleted.');
end
else
begin
WriteLn(Com, 'Message retained.');
MesgCurr := MesgCurr^.next;
end;
end
else
begin
WriteLn(Com, 'Message retained.');
MesgCurr := MesgCurr^.next
end;
end
else
MesgCurr := MesgCurr^.next;
end; {skip, backup & OK}
if update then
begin
Seek(summ_file, Pred(FilePos(summ_file)));
Write(summ_file, summ_rec)
end;
if (skip) and (Online) then
MesgCurr := MesgCurr^.next;
WriteLn(Com);
if (backup) then
begin
backup := False;
if (MesgCurr <> MesgBase) then
begin
This := MesgCurr;
MesgCurr := MesgBase; {find previous record}
MesgPrev := MesgBase;
if option in ['F', 'T'] then
begin
if option = 'F' then
this_type := 2
else
this_type := 1;
while (MesgCurr <> nil) and (MesgCurr^.Next <> This) do
begin
if MesgCurr^.TypMsg = this_type then
MesgPrev := MesgCurr;
MesgCurr := MesgCurr^.next;
end;
if MesgCurr^.TypMsg = this_type then
MesgPrev := MesgCurr;
MesgCurr := MesgPrev;
end
else
begin
while MesgCurr^.next <> This do
MesgCurr := MesgCurr^.next;
end;
end; {backup}
end;
end; {if mesgcurr<>nil}
end; {print msg and header}
if (not OK) then
begin
mult_cmds := False;
Cmd_Queue := '';
end;
nonstop := False;
end; {read messages}
end. { of MSGREAD.PAS}